home *** CD-ROM | disk | FTP | other *** search
/ Software of the Month Club 1996 September / Software of the Month Club 1996 September.iso / mac / Software Research Institute-SRI / Business / Alpha ƒ / Tcl / SystemCode / tcl.tcl < prev    next >
Encoding:
Text File  |  1995-12-28  |  7.3 KB  |  283 lines  |  [TEXT/ALFA]
  1.  
  2. # The menu.
  3. menu -n $tclMenu -p tclMenuProc {
  4.     "/Z<O<UtraceTclProc╔"
  5.     "/D<O<UdumpTraces"
  6.     "(-"
  7.     "rebuildTclIndices"
  8.     "(-"
  9.     "<U/PprocDefinition"
  10.     "getVarValue╔"
  11. }
  12. proc tclMenu {} {}
  13.  
  14. newModeVar Tcl prefixString {# } 0
  15. newModeVar Tcl wordWrap {0} 1
  16. newModeVar Tcl funcExpr {^proc *([+-a-zA-Z0-9]+)} 0
  17. newModeVar Tcl wordBreak {(\$)?[a-zA-Z0-9_]+} 0
  18. newModeVar Tcl wordBreakPreface {([^a-zA-Z0-9_\$]|.\$)} 0
  19. newModeVar Tcl elecLBrace    1    1
  20. newModeVar Tcl elecRBrace    1    1
  21. newModeVar Tcl elecReturn    1    1
  22. newModeVar Tcl autoMark    0    1
  23. newModeVar Tcl electricTab 1 1
  24.  
  25. set tclKeyWords {
  26.     then append array break case catch cd close concat continue elseif else eof 
  27.     error eval exec exit expr file flush foreach format for gets global glob 
  28.     history if incr info join lappend library lindex linsert list llength 
  29.     lrange lreplace lsearch lsort open pid proc puts pwd read regexp regsub 
  30.     rename return scancontext scan seek set source split string switch tell 
  31.     time trace unknown unset uplevel upvar while
  32.     
  33.     menu
  34. }
  35. if {[info exists Tclwords]} {set tclKeyWords [concat $tclKeyWords $Tclwords]}
  36. regModeKeywords -e {#} -c red -k blue Tcl $tclKeyWords
  37. unset tclKeyWords
  38.  
  39. #================================================================================
  40.  
  41. proc electricTclLeft {} {
  42.         global TclmodeVars
  43.         
  44.         if { [isSelection] } { deleteSelection }
  45.         if { [literalChar] } { insertText "\{"; return }
  46.         set pat {\}[ \t\r]*(else(if)?)[ \t\r]* }
  47.         if { !$TclmodeVars(elecLBrace) || \
  48.              (([lookAt [getPos]] != "\r") && ([getPos] != [maxPos])) || \
  49.              [catch {search -s -f 0 -r 1 "\}" [getPos]} res] || \
  50.              ![regexp $pat [getText [lindex $res 0] [getPos]] dum word] } {
  51.                 insertText "\{"
  52.                 return
  53.         }
  54.         replaceText [lindex $res 0] [getPos] "\} $word \{\r"
  55.         indentLine
  56.         if { $word == "elseif" } {
  57.                 previousLine
  58.                 endOfLine
  59.         }
  60. }
  61. bind '\{' <s> electricTclLeft Tcl
  62.  
  63.  
  64. proc electricTclRight {} {
  65.         global TclmodeVars
  66.                 
  67.         if { [isSelection] } { deleteSelection }
  68.         if { [literalChar] } { insertText "\}"; return }
  69.         if { !$TclmodeVars(elecRBrace) || \
  70.              [regexp {[^ \t]} [getText [lineStart [getPos]] [getPos]]] } {
  71.                 insertText "\}"
  72.                 blink [matchIt "\}" [expr [getPos] - 2]]
  73.                 return
  74.         }
  75.         set start [lineStart [getPos]]
  76.         insertText "\}"
  77.         backwardChar
  78.         indentLine
  79.         endOfLine
  80.         tclCarriageReturn
  81.         blink [matchIt "\}" $start]
  82. }
  83. bind '\}' <s> electricTclRight Tcl
  84.     
  85.  
  86. proc tclCarriageReturn {} {
  87.     global TclmodeVars
  88.     
  89.     insertText "\r"
  90.     if {$TclmodeVars(elecReturn)} {
  91.         indentLine
  92.     }
  93. }
  94. bind '\r' tclCarriageReturn Tcl
  95.  
  96.  
  97.  
  98. proc rebuildTclIndices {} {
  99.     global auto_path
  100.     set d [pwd]
  101.     # do we really need the next line? Alpha's original uses it.
  102.     cd
  103.     foreach dir $auto_path {
  104.         # if directory exists
  105.         if { ![catch { cd $dir } ] } {
  106.             # if there are any files
  107.             if { ![catch { glob *.*tcl } ] } {
  108.                 message "Building [file tail $dir] index╔"
  109.                 
  110.                 # if the '[incr tcl]' version exists, use that
  111.                 # use 'catch' also in case directory is write-protected
  112.                 if [catch { itcl_mkindex : *.*tcl } ] {
  113.                     # else try the normal one
  114.                     catch { auto_mkindex : *.*tcl }
  115.                 }
  116.             }
  117.         }
  118.     }
  119.     # redo the auto-mode-file connections (see "smarterSource.tcl")
  120.     message "Building the mode-file dependency array"
  121.     catch {autoModeFiles}
  122.     message ""
  123.     cd $d
  124. }
  125.  
  126.  
  127. proc tclMenuProc {menu item} {
  128.     global tclColoring
  129.  
  130.     eval $item
  131. }
  132.  
  133.  
  134. #===========================================================================
  135. # Debug a Tcl procedure.
  136. #===========================================================================
  137.  
  138. # Alpha TCL programming mode
  139.  
  140. proc traceTclProc {} {
  141.     global tclMenu
  142.     if {[llength [traceFunc status]]>2} {
  143.         catch {markMenuItem $tclMenu {traceTclProc╔} off}
  144.         catch {enableMenuItem $tclMenu dumpTraces off}
  145.         if {[string length [set data [traceDump]]]} {
  146.             if {[askyesno "Dump traces?"] == "yes"} {
  147.                 dumpTraces [string trimright [lindex [traceFunc status] 3] {,}] $data
  148.                 setWinInfo dirty 0
  149.             }
  150.         }
  151.         traceFunc off
  152.         message "Tracing off."
  153.         return
  154.     }
  155.     if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
  156.         set func [listpick -L $sel -p {Func Name:} [lsort -ignore [info procs]]]
  157.     } else {
  158.         set func [listpick -p {Func Name:} [lsort -ignore [info procs]]]
  159.     }
  160.     if {![string length $func]} return
  161.     traceFunc on $func ""
  162.     catch {markMenuItem $tclMenu {traceTclProc╔} on}
  163.     catch {enableMenuItem $tclMenu dumpTraces on}
  164.     message "Tracing '$func'╔"
  165. }
  166.  
  167.  
  168. proc dumpTraces {{name ""} {data ""}} {
  169.     if {![string length $name]} {
  170.         set name [string trimright [lindex [traceFunc status] 3] {,}]
  171.     }
  172.     if {![string length $data]} {
  173.         set data [traceDump]
  174.     }
  175.     
  176.     if {![string length $data]} {
  177.         message "Trace buffer empty"
  178.     } else {
  179.         new -n "* Trace '$name' *"
  180.         insertText $data
  181.         setWinInfo dirty 0
  182.         goto 0 
  183.     }
  184. }
  185.  
  186. proc setTclMode {} {
  187.     changeMode "Tcl"
  188. }
  189.  
  190. #================================================================================
  191. proc TclMarkFile {} {
  192.     set end [maxPos]
  193.     set pos 0
  194.     set l {}
  195.     set markExpr {^[ \t]*(itcl_class|proc|method)}
  196.     set class ""
  197.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  198.         set start [lindex $res 0]
  199.         set end [nextLineStart $start]
  200.         set t [getText $start $end]
  201.         switch [lindex $t 0] {
  202.             "proc" { set text [lindex $t 1] }
  203.             "method" { set text ${class}::[lindex $t 1] }
  204.             "itcl_class" { 
  205.                 set class [lindex $t 1]
  206.                 set text "${class} 000" 
  207.             }
  208.         }
  209.         set pos $end
  210.         set inds($text) [lineStart [expr $start - 1]]
  211.     }
  212.  
  213.     set already ""
  214.     
  215.     if {[info exists inds]} {
  216.         foreach f [lsort -ignore [array names inds]] {
  217.             set next [nextLineStart $inds($f)]
  218.             if { [string first "::" $f] != -1 } {
  219.                 set ff " :: [lindex [split $f "::"] 2]"
  220.             } elseif { [string first "000" $f] != -1 } {
  221.                 set ff "Class '[lindex $f 0]'"
  222.             } else {
  223.                 set ff $f
  224.             }
  225.             while { [lsearch -exact $already $ff] != -1 } {
  226.                 set ff "$ff "
  227.             }
  228.             lappend already $ff
  229.             setNamedMark $ff $inds($f) $next $next
  230.         }
  231.     }
  232. }
  233.  
  234. proc dummyTcl {} {}
  235.  
  236. #===============================================================================
  237. proc TclDblClick {from to shift option control} {
  238.     global HOME auto_index
  239.     
  240.     select $from $to
  241.     set text [getSelect]
  242.  
  243.     # Is it a loaded proc?
  244.     if {[info exists "auto_index($text)"]} {
  245.         editMark "$auto_index($text)" $text
  246.         return
  247.     }
  248.     # Is it a built-in Alpha command?
  249.     set lines [grep "^Ñ $text " "$HOME:Help:Alpha Commands"]
  250.     if {[string length $lines]} {
  251.         editMark "$HOME:Help:Alpha Commands" $text
  252.         setWinInfo read-only 1
  253.         return
  254.     }
  255.     # Is it a core Tcl command?
  256.     set lines [grep "^     $text -" "$HOME:Help:Tcl Commands"]
  257.     if {[string length $lines]} {
  258.         editMark "$HOME:Help:Tcl Commands" $text
  259.         setWinInfo read-only 1
  260.         return
  261.     }
  262.     # Is it a global variable?
  263.      if {[llength [info globals [string trimleft $text {$}]]]==1} {
  264.         showVarValue [string trimleft $text {$}]
  265.         return
  266.     }
  267.     message "No docs $shift $control $option"
  268. }
  269.  
  270. proc procDefinition {} {
  271.     global auto_index auto_help 
  272.     
  273.     if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
  274.         set func [listpick -L $sel -p {Proc?} [lsort -ignore [array names auto_index]]]
  275.     } else {
  276.         set func [listpick -p {Proc?} [lsort -ignore [array names auto_index]]]
  277.     }
  278.  
  279.     editMark "$auto_index($func)" $func
  280. }
  281.  
  282. #===============================================================================
  283.